home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / src / mocklisp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-04  |  7.0 KB  |  281 lines
  1. /* Mocklisp compatibility functions for XEmacs Lisp interpreter.
  2.    Copyright (C) 1985, 1986, 1992, 1993 Free Software Foundation, Inc.
  3.  
  4. This file is part of XEmacs.
  5.  
  6. XEmacs is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by the
  8. Free Software Foundation; either version 2, or (at your option) any
  9. later version.
  10.  
  11. XEmacs is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  14. for more details.
  15.  
  16. You should have received a copy of the GNU General Public License
  17. along with XEmacs; see the file COPYING.  If not, write to the Free
  18. Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. /* Synched up with: FSF 19.28. */
  21.  
  22.  
  23. /* Compatibility for mocklisp */
  24.  
  25. #include <config.h>
  26.  
  27. #ifdef MOCKLISP_SUPPORT /* whole file */
  28.  
  29. #include "lisp.h"
  30. #include "buffer.h"
  31.  
  32. Lisp_Object Qmocklisp;
  33. Lisp_Object Qmocklisp_arguments;
  34. Lisp_Object Vmocklisp_arguments;
  35.  
  36. /* Now in lisp code ("macrocode...")
  37. * DEFUN ("ml-defun", Fml_defun, Sml_defun, 0, UNEVALLED, 0,
  38. *  "Define mocklisp functions")
  39. *  (args)
  40. *     Lisp_Object args;
  41. * {
  42. *  Lisp_Object elt;
  43. *
  44. *   while (!NILP (args))
  45. *     {
  46. *       elt = Fcar (args);
  47. *       Ffset (Fcar (elt), Fcons (Qmocklisp, Fcdr (elt)));
  48. *       args = Fcdr (args);
  49. *     }
  50. *   return Qnil;
  51. * }
  52. */
  53.  
  54. DEFUN ("ml-if", Fml_if, Sml_if, 0, UNEVALLED, 0, "Mocklisp version of `if'.")
  55.   (args)
  56.      Lisp_Object args;
  57. {
  58.   /* This function can GC */
  59.   Lisp_Object val;
  60.   struct gcpro gcpro1;
  61.  
  62.   GCPRO1 (args);
  63.   while (!NILP (args))
  64.     {
  65.       val = Feval (Fcar (args));
  66.       args = Fcdr (args);
  67.       if (NILP (args)) break;
  68.       if (XINT (val))
  69.     {
  70.       val = Feval (Fcar (args));
  71.       break;
  72.     }
  73.       args = Fcdr (args);
  74.     }
  75.   UNGCPRO;
  76.   return val;
  77. }
  78.  
  79. /* Now converted to regular "while" by hairier conversion code.
  80. * DEFUN ("ml-while", Fml_while, Sml_while, 1, UNEVALLED, 0, "while  for mocklisp programs")
  81. *   (args)
  82. *      Lisp_Object args;
  83. * {
  84. *   Lisp_Object test, body, tem;
  85. *   struct gcpro gcpro1, gcpro2;
  86. *
  87. *   GCPRO2 (test, body);
  88. *
  89. *   test = Fcar (args);
  90. *   body = Fcdr (args);
  91. *   while (tem = Feval (test), XINT (tem))
  92. *     {
  93. *       QUIT;
  94. *       Fprogn (body);
  95. *    }
  96. *
  97. *   UNGCPRO;
  98. *   return Qnil;
  99. *}
  100. */
  101.  
  102. /* This is the main entry point to mocklisp execution.
  103.  When eval sees a mocklisp function being called, it calls here
  104.  with the unevaluated argument list */
  105.  
  106. Lisp_Object
  107. ml_apply (function, args)
  108.      Lisp_Object function, args;
  109. {
  110.   /* This function can GC */
  111.   int speccount = specpdl_depth ();
  112.   Lisp_Object val;
  113.  
  114.   specbind (Qmocklisp_arguments, args);
  115.   val = Fprogn (Fcdr (function));
  116.   return unbind_to (speccount, val);
  117. }
  118.  
  119. /* now in lisp code
  120.  * DEFUN ("ml-nargs", Fml_nargs, Sml_nargs, 0, 0, 0,
  121.  *   "Number of arguments to currently executing mocklisp function.")
  122.  *   ()
  123.  * {
  124.  *   if (EQ (Vmocklisp_arguments, Qinteractive))
  125.  *     return make_number (0);
  126.  *   return Flength (Vmocklisp_arguments);
  127.  * }
  128.  */
  129.  
  130. /* now in lisp code
  131.  * DEFUN ("ml-arg", Fml_arg, Sml_arg, 1, 2, 0,
  132.  *   "Argument number N to currently executing mocklisp function.")
  133.  *   (n, prompt)
  134.  *      Lisp_Object n, prompt;
  135.  * {
  136.  *   if (EQ (Vmocklisp_arguments, Qinteractive))
  137.  *     return call1 (Qread_from_minibuffer, prompt);
  138.  *   CHECK_INT (n, 0);
  139.  *   XSETINT (n, XINT (n) - 1);    /* Mocklisp likes to be origin-1 */
  140.  *   return Fcar (Fnthcdr (n, Vmocklisp_arguments));
  141.  * }
  142.  */
  143.  
  144. /* now in lisp code
  145.  * DEFUN ("ml-interactive", Fml_interactive, Sml_interactive, 0, 0, 0,
  146.  *  "True if currently executing mocklisp function was called interactively.")
  147.  *   ()
  148.  * {
  149.  *   return (EQ (Vmocklisp_arguments, Qinteractive)) ? Qt : Qnil;
  150.  * }
  151.  */
  152.  
  153. /* ???  Isn't this the same as `provide-prefix-arg' from mlsupport.el? */
  154. DEFUN ("ml-provide-prefix-argument", Fml_provide_prefix_argument, Sml_provide_prefix_argument,
  155.   2, UNEVALLED, 0,
  156.   "Evaluate second argument, using first argument as prefix arg value.")
  157.   (args)
  158.      Lisp_Object args;
  159. {
  160.   /* This function can GC */
  161.   struct gcpro gcpro1;
  162.   GCPRO1 (args);
  163.   Vcurrent_prefix_arg = Feval (Fcar (args));
  164.   UNGCPRO;
  165.   return Feval (Fcar (Fcdr (args)));
  166. }
  167.  
  168. DEFUN ("ml-prefix-argument-loop", Fml_prefix_argument_loop,
  169.        Sml_prefix_argument_loop,
  170.        0, UNEVALLED, 0,
  171.   "")
  172.   (args)
  173.      Lisp_Object args;
  174. {
  175.   /* This function can GC */
  176.   Lisp_Object tem;
  177.   int i;
  178.   struct gcpro gcpro1;
  179.  
  180.   /* Set `arg' in case we call a built-in function that looks at it.  Still are a few. */
  181.   if (NILP (Vcurrent_prefix_arg))
  182.     i = 1;
  183.   else
  184.     {
  185.       tem = Vcurrent_prefix_arg;
  186.       if (CONSP (tem))
  187.     tem = Fcar (tem);
  188.       if (EQ (tem, Qminus))
  189.     i = -1;
  190.       else i = XINT (tem);
  191.     }
  192.  
  193.   GCPRO1 (args);
  194.   while (i-- > 0)
  195.     Fprogn (args);
  196.   UNGCPRO;
  197.   return Qnil;
  198. }
  199.  
  200. /* now in lisp code
  201.  * DEFUN ("ml-substr", Fml_substr, Sml_substr, 3, 3, 0,
  202.  *   "Return a substring of STRING, starting at index FROM and of length LENGTH.\n\
  203.  * If either FROM or LENGTH is negative, the length of STRING is added to it.")
  204.  *   (string, from, to)
  205.  *      Lisp_Object string, from, to;
  206.  * {
  207.  *   CHECK_STRING (string, 0);
  208.  *   CHECK_INT (from, 1);
  209.  *   CHECK_INT (to, 2);
  210.  * 
  211.  *   if (XINT (from) < 0)
  212.  *     XSETINT (from, XINT (from) + string_length (XSTRING (string)));
  213.  *   if (XINT (to) < 0)
  214.  *     XSETINT (to, XINT (to) + string_length (XSTRING (string)));
  215.  *   XSETINT (to, XINT (to) + XINT (from));
  216.  *   return Fsubstring (string, from, to);
  217.  * }
  218.  */
  219.  
  220. /* now in lisp code
  221.  * DEFUN ("insert-string", Finsert_string, Sinsert_string, 0, MANY, 0,
  222.  *   "Mocklisp-compatibility insert function.\n\
  223.  * Like the function `insert' except that any argument that is a number\n\
  224.  * is converted into a string by expressing it in decimal.")
  225.  *   (nargs, args)
  226.  *      int nargs;
  227.  *      Lisp_Object *args;
  228.  * {
  229.  *   int argnum;
  230.  *   Lisp_Object tem;
  231.  * 
  232.  *   for (argnum = 0; argnum < nargs; argnum++)
  233.  *     {
  234.  *       tem = args[argnum];
  235.  *     retry:
  236.  *       if (INTP (tem))
  237.  *     tem = Fnumber_to_string (tem);
  238.  *       if (STRINGP (tem))
  239.  *     buffer_insert1 (current_buffer, tem);
  240.  *       else
  241.  *     {
  242.  *       tem = wrong_type_argument (Qstringp, tem);
  243.  *       goto retry;
  244.  *     }
  245.  *     }
  246.  *   return Qnil;
  247.  * }
  248.  */
  249.  
  250. /************************************************************************/
  251. /*                            initialization                            */
  252. /************************************************************************/
  253.  
  254. void
  255. syms_of_mocklisp (void)
  256. {
  257.   defsymbol (&Qmocklisp, "mocklisp");
  258.   defsymbol (&Qmocklisp_arguments, "mocklisp-arguments");
  259.  
  260. /*defsubr (&Sml_defun);*/
  261.   defsubr (&Sml_if);
  262. /*defsubr (&Sml_while);*/
  263. /*defsubr (&Sml_nargs);*/
  264. /*defsubr (&Sml_arg);*/
  265. /*defsubr (&Sml_interactive);*/
  266.   defsubr (&Sml_provide_prefix_argument);
  267.   defsubr (&Sml_prefix_argument_loop);
  268. /*defsubr (&Sml_substr);*/
  269. /*defsubr (&Sinsert_string);*/
  270. }
  271.  
  272. void
  273. vars_of_mocklisp (void)
  274. {
  275.   DEFVAR_LISP ("mocklisp-arguments", &Vmocklisp_arguments,
  276.     "While in a mocklisp function, the list of its unevaluated args.");
  277.   Vmocklisp_arguments = Qt;
  278. }
  279.  
  280. #endif /* MOCKLISP_SUPPORT */
  281.